home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 26 / Cream of the Crop 26.iso / program / qbsnip.zip / TEXTMELT.BAS < prev    next >
Encoding:
BASIC Source File  |  1997-06-20  |  2.9 KB  |  106 lines
  1. 'Graphics melt #1 and #2
  2. '
  3. '3/2/1997 By: - Nick Kochakian -
  4. '
  5. 'This melts any graphic you put a "box" around.
  6. '
  7. 'If you have any comments or questions e-mail me at: nickK@worldnet.att.net
  8. '
  9. 'Have fun! :)
  10.  
  11. ' Modified by Tika Carr (t.carr@pobox.com) on June 20, 1997
  12. '  o Optimized the code some
  13. '  o Made into a callable subroutine
  14. '  o You can now position text anywhere on the screen and have it melt
  15. '  o Delay loop will ensure proper melt speed, no matter what size the
  16. '    message is.
  17. '  o Added the ability to melt with another color (nice for "bleeding"
  18. '    messages!
  19. '  o Checks to be sure string is not too long
  20. '
  21. ' This is NOT a transparent text.
  22. ' Press any key at any time to go to the next stage of the demo
  23.  
  24. DEFINT A-Z
  25. DECLARE SUB MeltMsg (mx%, my%, message$, style%, TxtClr%, MeltCol%)
  26.  
  27. SCREEN 13 ' only works in 320 x 200 x 256 mode
  28.  
  29. 'MeltMsg x, y, message$, sytle, color of text, color of melting
  30.  
  31. 'style = 1  'The way to melt the graphic / text on the screen
  32. 'style = 2  'boil / blend
  33.  
  34. MeltMsg 6, 3, "Here's a Toxic Blood Effect!", 1, 10, 12
  35.  
  36. CLS
  37. MeltMsg 10, 10, "A boiling effect", 2, 13, 13  'same color can also be used
  38.  
  39. SCREEN 0, 0, 0, 0: WIDTH 80: COLOR 7, 0: CLS : END
  40.  
  41. SUB MeltMsg (mx, my, message$, style, TxtClr, MeltCol)
  42.  
  43. strlen = LEN(message$) + 1
  44. IF strlen > 40 THEN
  45.   SCREEN 0, 0, 0, 0: WIDTH 80: COLOR 7, 0: CLS
  46.   PRINT "ERROR: String too long"
  47.   END
  48. END IF
  49.  
  50. RANDOMIZE TIMER
  51. DIM x(10000), y(10000), c(10000), o(10000)
  52.  
  53. IF style < 1 OR style > 2 THEN style = 1   ' Ensure proper melt defaults
  54. COLOR TxtClr: LOCATE my, mx: PRINT message$
  55.  
  56. 'Calculate delay based on size of string
  57. 'The larger the string, the less delay time (as it takes longer to render)
  58. SELECT CASE strlen
  59.   CASE IS < 31: delay = 10000
  60.   CASE IS < 20: delay = 20000
  61.   CASE IS < 10: delay = 30000
  62.   CASE ELSE: delay = 0
  63. END SELECT
  64.  
  65. x2 = 8 * (mx + strlen) - 16: y2 = 8 * (my - 1) + 8: x = mx: y = my
  66. x1 = x: y1 = y: px = 1: py = 1: pc = 1: onc = 1: pixcnt = 0
  67.  
  68. DO
  69.   IF POINT(x, y) > 0 THEN
  70.     'col = POINT(x, y)
  71.     'col = 14
  72.     x(px) = x: y(py) = y: c(pc) = MeltCol
  73.     px = px + 1: py = py + 1: pc = pc + 1: pixcnt = pixcnt + 1
  74.   END IF
  75.   x = x + 1: IF x > x2 THEN x = x1: y = y + 1
  76. LOOP UNTIL y > y2
  77.  
  78. 'px = px + 1: py = py + 1
  79. x(px) = -1: y(py) = -1
  80. px = 1: py = 1: pc = 1
  81.  
  82. WHILE INKEY$ = ""
  83.   DO
  84.     numend = INT(RND * pixcnt) + 1
  85.     FOR i = 1 TO numend
  86.       px = px + 1: py = py + 1: pc = pc + 1: onc = onc + 1
  87.     NEXT
  88.     oncbak = onc: onc = 1: onccntr = 0
  89.     FOR i = 1 TO pixcnt: onc = onc + 1: onccntr = onccntr + 1: NEXT
  90.  
  91.     IF onccntr = pixcnt THEN
  92.       onc = oncbak: onc = 1
  93.       FOR i = 1 TO pixcnt: o(onc) = 0: onc = onc + 1: NEXT: onc = 1
  94.     END IF
  95.   LOOP WHILE o(onc) = 1
  96.   IF style = 2 THEN PSET (x(px), y(py)), 0
  97.   y(py) = y(py) + 1: PSET (x(px), y(py)), c(pc): o(onc) = 1
  98.   px = 1: py = 1: pc = 1: onc = 1
  99.   IF delay > 0 THEN FOR i = 1 TO delay: NEXT
  100. WEND
  101.  
  102.  
  103. END SUB
  104.  
  105.  
  106.